Hardcore Visual Basic 5.0 (2nd Edition)/Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso/Code/fileinfo.cls

Text File | 1997-06-14 | 10KB | 296 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CFileInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Public Enum EErrorFileInfo
    eeBaseFileInfo = 13070      ' CFileInfo
End Enum

Public Enum EItemType
    eitFile = 1                 ' File or directory
    eitDrive                    ' Drive
    eitID                       ' PIDL passed to us
    eitFolder                   ' PIDL created by us from special folder
End Enum

Private Enum EItemState
    eisNotCreated
    eisFile                     ' File or directory
    eisDrive                    ' Drive
    eisID                       ' PIDL passed to us
    eisFolder                   ' PIDL created by us from special folder
End Enum
Private eis As EItemState       ' How object was created
Private vItem As Variant        ' File name or PIDL
Private shfi As SHFILEINFO      ' Info from SHGetFileInfo
Private fd As WIN32_FIND_DATA   ' Info from FindFirstFile
Private afAttr As Long          ' File attributes
Private afOption As Long        ' Options for SHGetFileInfo

Public Enum EExeType
    eetWin16Exe = &H454E
    eetDosExe = &H5A4D
    eetWin32Exe = &H4550
    eetWin32Console = &H4543
End Enum

Property Get item() As Variant
Attribute item.VB_UserMemId = 0
    item = vItem
End Property

Property Let item(vItemA As Variant)
    Dim h As Long, f As Long, af As Long
    Destroy     ' Clear any previous assignment
    If VarType(vItemA) = vbString Then
        ' String item is a file, directory, or drive
        If Len(vItemA) <= 3 And Mid$(vItemA, 2, 1) = ":" Then
            ' Must be drive, get attributes
            afAttr = 0: afOption = 0
        Else
            ' No terminating backslashes
            MUtility.DenormalizePath vItemA
            ' For file, get information in advance
            h = FindFirstFile(vItemA, fd)
            If h = hInvalid Then ApiRaise Err.LastDllError
            FindClose h
            afAttr = fd.dwFileAttributes
            afOption = SHGFI_USEFILEATTRIBUTES
        End If
        eis = eisFile
        af = afOption And (Not SHGFI_PIDL) Or _
             SHGFI_DISPLAYNAME Or SHGFI_TYPENAME
        f = SHGetFileInfo(vItemA, afAttr, shfi, LenB(shfi), af)
    Else
        ' Integer item is a special folder constant or pidl
        If vItemA < 50 Then
            ' Turn special folder location into a pidl
            Dim pidl As Long
            SHGetSpecialFolderLocation 0, CLng(vItemA), pidl
            vItemA = pidl
            eis = eisFolder
        Else
            eis = eisID
            pidl = vItemA
        End If
        ' For special folders or other PIDLs, everything comes from system
        afAttr = 0: afOption = 0
        ' Get item ID pointer, but don't use attributes
        af = SHGFI_PIDL Or SHGFI_DISPLAYNAME Or _
             SHGFI_TYPENAME
        f = SHGetItemInfo(pidl, afAttr, shfi, Len(shfi), af)
    End If
    If f Then
        vItem = vItemA
    Else
        eis = eisNotCreated
    End If
End Property

' In a drive loop it's more efficient to create from drive data
Sub CreateFromDrive(sRootA As String, sKind As String, _
                    rTotal As Double, rFree As Double)
    Dim f As Long
    Destroy
    afAttr = 0
    fd.dwFileAttributes = 0
    fd.ftLastAccessTime = 0
    fd.ftLastWriteTime = 0
    fd.ftCreationTime = 0
    fd.nFileSizeLow = 0
    fd.dwReserved0 = CLng(rTotal / 1000000)
    fd.dwReserved1 = CLng(rFree / 1000000)
    f = SHGetFileInfo(sRootA, afAttr, shfi, LenB(shfi), _
                      SHGFI_DISPLAYNAME Or SHGFI_TYPENAME Or SHGFI_ATTRIBUTES)
    MBytes.StrToBytes fd.cAlternateFileName, sKind
    If f Then
        vItem = sRootA
        eis = eisDrive
    End If
End Sub

' In a FindFirstFile loop it's more efficient to create from file data
Sub CreateFromFile(sFileA As String, ByVal afAttrA As Long, _
                   ByVal cLenA As Long, ftModifiedA As Currency, _
                   ftAccessedA As Currency, ftCreatedA As Currency)
    Dim f As Long
    Destroy
    afAttr = afAttrA
    fd.dwFileAttributes = afAttrA
    fd.ftLastAccessTime = ftAccessedA
    fd.ftLastWriteTime = ftModifiedA
    fd.ftCreationTime = ftCreatedA
    fd.nFileSizeLow = cLenA
    f = SHGetFileInfo(sFileA, afAttr, shfi, LenB(shfi), _
                      SHGFI_DISPLAYNAME Or SHGFI_TYPENAME Or SHGFI_ATTRIBUTES)
    If f Then
        vItem = sFileA
        eis = eisFile
    End If
End Sub

Sub CreateFromNamePidl(sNameA As String, ByVal pidl As Long)
    Dim f As Long, c As Long, s As String
    Destroy
    afAttr = 0
    fd.dwFileAttributes = 0
    fd.ftLastAccessTime = 0
    fd.ftLastWriteTime = 0
    fd.ftCreationTime = 0
    fd.nFileSizeLow = 0
    vItem = pidl
    eis = eisID
    If UnicodeTypeLib Then
        s = sNameA & vbNullChar
        c = Len(s) * 2
        CopyMemoryStr shfi.szDisplayName(0), s, c
    Else
        s = sNameA & vbNullChar
        c = Len(s)
        CopyMemoryStr shfi.szDisplayName(0), s, c
    End If
End Sub

Private Sub Destroy()
    ' Free any pidl we created from special folder
    If eis = eisFolder Then Allocator.Free vItem
    eis = eisNotCreated
    vItem = Empty
End Sub

Property Get DisplayName() As String
    If eis Then DisplayName = MBytes.ByteZToStr(shfi.szDisplayName)
    If DisplayName = sEmpty Then DisplayName = "Unknown"
End Property

' Returns file type
Property Get TypeName() As String
    If eis Then TypeName = MBytes.ByteZToStr(shfi.szTypeName)
    If TypeName = sEmpty Then TypeName = "None"
End Property

Function SmallIcon(Optional afOverlay As Long = 0) As Picture
    Dim shfiT As SHFILEINFO
    If eis = eisNotCreated Then Exit Function
    ' Filter out any invalid flags -- only overlays allowed
    afOverlay = afOverlay And (SHGFI_LINKOVERLAY Or SHGFI_SELECTED _
                               Or SHGFI_OPENICON)
    ' Add in standard and small icon flags
    afOverlay = afOverlay Or afOption Or SHGFI_ICON Or SHGFI_SMALLICON
    GetFileItemInfo vItem, shfiT, afOverlay, afAttr
    Set SmallIcon = MPicTool.IconToPicture(shfiT.hIcon)
End Function

Function LargeIcon(Optional afOverlay As Long = 0) As Picture
    Dim shfiT As SHFILEINFO
    If eis = eisNotCreated Then Exit Function
    ' Filter out any invalid flags -- only overlays allowed
    afOverlay = afOverlay And (SHGFI_LINKOVERLAY Or SHGFI_SELECTED _
                               Or SHGFI_OPENICON)
    ' Add in standard and large icon flags
    afOverlay = afOverlay Or afOption Or SHGFI_ICON Or SHGFI_LARGEICON
    GetFileItemInfo vItem, shfiT, afOverlay, afAttr
    Set LargeIcon = MPicTool.IconToPicture(shfiT.hIcon)
End Function

Function ShellIcon(Optional afOverlay As Long = 0) As Picture
    Dim shfiT As SHFILEINFO
    If eis = eisNotCreated Then Exit Function
    ' Filter out any invalid flags -- only overlays allowed
    afOverlay = afOverlay And (SHGFI_LINKOVERLAY Or SHGFI_SELECTED _
                               Or SHGFI_OPENICON)
    ' Add in standard and large icon flags
    afOverlay = afOverlay Or afOption Or SHGFI_ICON Or SHGFI_SHELLICONSIZE
    GetFileItemInfo vItem, shfiT, afOverlay, afAttr
    Set ShellIcon = MPicTool.IconToPicture(shfiT.hIcon)
End Function

Function Icon(afKind As Long) As Picture
    Dim shfiT As SHFILEINFO
    If eis = eisNotCreated Then Exit Function
    GetFileItemInfo vItem, shfiT, afOption Or SHGFI_ICON Or afKind, afAttr
    Set Icon = MPicTool.IconToPicture(shfiT.hIcon)
End Function

' Retrieves file attribute flags:
'       ReadOnly        Hidden      System      Directory
'       Archive         Normal      Temporary   Compressed
Function Attributes() As Long
    If eis = eisFile Then Attributes = fd.dwFileAttributes
End Function

Function length() As Long
    If eis = eisFile Then length = fd.nFileSizeLow
End Function

Function Modified() As Date
    If eis = eisFile Then Modified = MFileTool.Win32ToVbTime(fd.ftLastWriteTime)
End Function

Function Created() As Date
    If eis = eisFile Then Created = MFileTool.Win32ToVbTime(fd.ftCreationTime)
End Function

Function Accessed() As Date
    If eis = eisFile Then Accessed = MFileTool.Win32ToVbTime(fd.ftLastAccessTime)
End Function

Function TotalKilo() As Long
    If eis = eisDrive Then TotalKilo = fd.dwReserved0
End Function

Function FreeKilo() As Long
    If eis = eisDrive Then FreeKilo = fd.dwReserved1
End Function

Function DriveType() As String
    If eis = eisDrive Then DriveType = MBytes.ByteZToStr(fd.cAlternateFileName)
End Function

Function ItemType() As EItemType
    ItemType = eis
End Function

Private Function GetFileItemInfo(vFileItem As Variant, fi As SHFILEINFO, _
                                 ByVal afOption As Long, _
                                 Optional afAttr As Long = 0) As Long
    Dim f As Long
    If VarType(vFileItem) = vbString Then
        afOption = afOption And (Not SHGFI_PIDL)
        f = SHGetFileInfo(CStr(vFileItem), afAttr, fi, LenB(fi), afOption)
    Else
        afOption = afOption Or SHGFI_PIDL
        f = SHGetItemInfo(CLng(vFileItem), 0, fi, LenB(fi), afOption)
    End If
    GetFileItemInfo = f
End Function

#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
    Dim sText As String, sSource As String
    If e > 1000 Then
        sSource = App.ExeName & ".FileInfo"
        Select Case e
        Case eeBaseFileInfo
            BugAssert True
       ' Case ee...
       '     Add additional errors
        End Select
        Err.Raise COMError(e), sSource, sText
    Else
        ' Raise standard Visual Basic error
        sSource = App.ExeName & ".VBError"
        Err.Raise e, sSource
    End If
End Sub
#End If